home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / scsh / flock.scm < prev    next >
Text File  |  1995-10-22  |  4KB  |  142 lines
  1. ;;; Scsh
  2. ;;; Posix advisory record-locking for file descriptors.
  3. ;;; These procs may only be applied to integer file descriptors; 
  4. ;;; they may not be applied to ports.
  5. ;;; Copyright (c) 1995 by David Albertz and Olin Shivers.
  6. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  7.  
  8. ;;; C syscall interface
  9. ;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (foreign-source
  12.   "#include <sys/types.h>"
  13.   "#include <unistd.h>"
  14.   "#include <fcntl.h>"
  15.   ""
  16.   "extern int errno;"
  17.   ""
  18.   "/* Make sure foreign-function stubs interface to the C funs correctly: */"
  19.   "#include \"flock1.h\""
  20.   ""
  21.   "#define errno_or_false(x) (((x) == -1) ? ENTER_FIXNUM(errno) : SCHFALSE)"
  22.   "" "")
  23.  
  24. (define-foreign %set-lock (set_lock (integer fd)
  25.                     (integer cmd)
  26.                     (integer type)
  27.                     (integer whence)
  28.                     (integer start)
  29.                     (integer len))
  30.   (to-scheme integer errno_or_false))
  31.  
  32. (define-foreign %get-lock (get_lock (integer fd)
  33.                     (integer cmd)
  34.                     (integer type)
  35.                     (integer whence)
  36.                     (integer start)
  37.                     (integer len))
  38.   (to-scheme integer errno_or_false)
  39.   integer    ; lock type
  40.   integer    ; whence
  41.   integer    ; start
  42.   integer    ; len
  43.   integer)    ; pid
  44.                        
  45.  
  46. ;;; The LOCK record type
  47. ;;;;;;;;;;;;;;;;;;;;;;;;
  48.  
  49. (define-record %lock-region
  50.   exclusive?
  51.   start            ; integer
  52.   len            ; Positive integer or #f
  53.   whence        ; seek/set, seek/delta, or seek/end.
  54.   pid              ; Process holding lock
  55.   )
  56.  
  57. (define lock-region?               %lock-region?)
  58. (define lock-region:exclusive?     %lock-region:exclusive?)
  59. (define lock-region:whence         %lock-region:whence)
  60. (define lock-region:start          %lock-region:start)
  61. (define lock-region:len            %lock-region:len)
  62. (define lock-region:pid            %lock-region:pid)
  63. (define set-lock-region:exclusive? set-%lock-region:exclusive?)
  64. (define set-lock-region:whence     set-%lock-region:whence)
  65. (define set-lock-region:start      set-%lock-region:start)
  66. (define set-lock-region:len        set-%lock-region:len)
  67. (define set-lock-region:pid        set-%lock-region:pid)
  68.  
  69. (define (make-lock-region exclusive? start len . maybe-whence)
  70.   (let ((whence (optional-arg maybe-whence seek/set)))
  71.     (make-%lock-region exclusive? start len whence 0)))
  72.  
  73.  
  74. ;;; Internal middleman routine
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76.  
  77. (define (call-lock-region proc cmd fdes lock)
  78.   (check-arg lock-region? lock proc)
  79.   (let ((lock-type (if (lock-region:exclusive? lock) lock/write lock/read)))
  80.     (proc fdes cmd lock-type
  81.       (lock-region:whence lock)
  82.       (lock-region:start lock)
  83.       (lock-region:len lock))))
  84.  
  85.  
  86. ;;; The main routines
  87. ;;;;;;;;;;;;;;;;;;;;;
  88.  
  89. (define (lock-region fdes lock)
  90.   (let lp ()
  91.     (cond ((call-lock-region %set-lock fcntl/set-record-lock fdes lock) =>
  92.            (lambda (errno)
  93.          (if (= errno errno/intr) (lp)     ; Retry on interrupt.
  94.          (errno-error errno lock-region fdes lock)))))))
  95.  
  96.  
  97. ;;; Return true/false indicating success/failure.
  98.  
  99. (define (lock-region/no-block fdes lock)
  100.   (cond ((call-lock-region %set-lock fcntl/set-record-lock-noblock fdes lock) 
  101.          => (lambda (errno)
  102.           (if (= errno errno/again) #f
  103.           (errno-error errno lock-region/no-block fdes lock))))
  104.     (else #t)))
  105.  
  106.  
  107. ;;; Return first lock overlapping LOCK; if none, return #f.
  108.  
  109. (define (get-lock-region fdes lock)
  110.   (receive (err type whence start len pid)
  111.            (call-lock-region %get-lock fcntl/get-record-lock fdes lock)
  112.     (if err (errno-error err get-lock-region fdes lock)
  113.     (and (not (= type lock/release))
  114.          (make-%lock-region (= type lock/write) start len whence pid)))))
  115.  
  116.  
  117.  
  118. (define (unlock-region fdes lock)
  119.   (cond ((call-lock-region %set-lock lock/release fdes lock) =>
  120.          (lambda (errno) (errno-error errno unlock-region fdes lock)))))
  121.  
  122.  
  123. ;;; Locks with dynamic extent -- with and without sugar
  124. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  125. ;;; Throwing out frees the lock. Don't throw back in.
  126.  
  127. (define (with-region-lock* fd lock thunk)
  128.   (let ((returned? #f))
  129.     (dynamic-wind (lambda ()
  130.             (if returned?
  131.             (error "Can't throw back into a with-region-lock" lock)
  132.             (lock-region fd lock)))
  133.           thunk
  134.           (lambda ()
  135.             (unlock-region fd lock)
  136.             (set! returned? #t)))))
  137.  
  138. (define-syntax with-region-lock
  139.   (syntax-rules ()
  140.     ((with-region-lock fd lock body ...)
  141.      (with-region-lock* fd lock (lambda () body ...)))))
  142.